home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / numerical / slatec / zs1s2.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  2.0 KB  |  62 lines
  1. ;;; Compiled by f2cl version 2.0 beta 2002-05-06
  2. ;;; 
  3. ;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
  4. ;;;           (:coerce-assigns :as-needed) (:array-type ':simple-array)
  5. ;;;           (:array-slicing nil) (:declare-common nil)
  6. ;;;           (:float-format double-float))
  7.  
  8. (in-package "SLATEC")
  9.  
  10.  
  11. (let ((zeror 0.0) (zeroi 0.0))
  12.   (declare (type double-float zeroi zeror))
  13.   (defun zs1s2 (zrr zri s1r s1i s2r s2i nz ascle alim iuf)
  14.     (declare (type double-float zrr zri s1r s1i s2r s2i ascle alim)
  15.              (type f2cl-lib:integer4 nz iuf))
  16.     (prog ((idum 0) (aa 0.0) (aln 0.0) (as1 0.0) (as2 0.0) (c1i 0.0) (c1r 0.0)
  17.            (s1di 0.0) (s1dr 0.0))
  18.       (declare (type double-float s1dr s1di c1r c1i as2 as1 aln aa)
  19.                (type f2cl-lib:integer4 idum))
  20.       (setf nz 0)
  21.       (setf as1 (zabs s1r s1i))
  22.       (setf as2 (zabs s2r s2i))
  23.       (if (and (= s1r 0.0) (= s1i 0.0)) (go label10))
  24.       (if (= as1 0.0) (go label10))
  25.       (setf aln (+ (- (- zrr) zrr) (f2cl-lib:flog as1)))
  26.       (setf s1dr s1r)
  27.       (setf s1di s1i)
  28.       (setf s1r zeror)
  29.       (setf s1i zeroi)
  30.       (setf as1 zeror)
  31.       (if (< aln (- alim)) (go label10))
  32.       (multiple-value-bind
  33.           (var-0 var-1 var-2 var-3 var-4)
  34.           (zlog s1dr s1di c1r c1i idum)
  35.         (declare (ignore var-0 var-1))
  36.         (setf c1r var-2)
  37.         (setf c1i var-3)
  38.         (setf idum var-4))
  39.       (setf c1r (- c1r zrr zrr))
  40.       (setf c1i (- c1i zri zri))
  41.       (multiple-value-bind
  42.           (var-0 var-1 var-2 var-3)
  43.           (zexp c1r c1i s1r s1i)
  44.         (declare (ignore var-0 var-1))
  45.         (setf s1r var-2)
  46.         (setf s1i var-3))
  47.       (setf as1 (zabs s1r s1i))
  48.       (setf iuf (f2cl-lib:int-add iuf 1))
  49.      label10
  50.       (setf aa (max as1 as2))
  51.       (if (> aa ascle) (go end_label))
  52.       (setf s1r zeror)
  53.       (setf s1i zeroi)
  54.       (setf s2r zeror)
  55.       (setf s2i zeroi)
  56.       (setf nz 1)
  57.       (setf iuf 0)
  58.       (go end_label)
  59.      end_label
  60.       (return (values nil nil s1r s1i s2r s2i nz nil nil iuf)))))
  61.  
  62.